home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / dbms_mag / 9108 / zdsample.prg < prev   
Text File  |  1991-03-15  |  23KB  |  819 lines
  1. ***************************************************************************
  2. * File name: ZDSAMPLE.PRG
  3. * This program is demonstrates the use of Zero-Balanced Distribution Engine
  4. * Copyright (c) 1986-1991  James F. Shaughnessy, Jr.
  5. *     All rights reserved
  6. * Portions of this code were developed using Ashton-Tate, dBase III Plus
  7. * Portions of this code were developed using Fox Software Foxbase + 2.10
  8. * This version, March, 1991, developed using Fox Software FoxPro 1.02
  9. * 
  10. ***************************************************************************
  11. SET TALK OFF
  12. SET STATUS OFF
  13. vid_bright = "R+/B           " 
  14. vid_nrml   = "GR+/B,W+/R,B   " 
  15. vid_rvrs   = "W+/R           " 
  16. SET COLOR TO &vid_nrml
  17. IF .NOT. FILE ("TRANHDR.DBF")
  18.    CREATE Tranhdr FROM tranhdr.str
  19. ENDIF
  20. IF .NOT. FILE ("TRANDSTR.DBF")
  21.    CREATE Trandstr FROM trandstr.str
  22. ENDIF
  23. SELECT 1
  24. USE Tranhdr
  25. SELECT 2
  26. USE Trandstr
  27. SELECT 3
  28. SET SAFETY OFF
  29. CREATE Dstrwork FROM trandstr.str
  30. SET SAFETY ON
  31. SELECT 1
  32. IF "FOXBASE"$UPPER(VERSION())
  33.    SET PROCEDURE TO zdsample
  34. ENDIF
  35. DO smplmenu
  36. RETURN
  37. *
  38. PROCEDURE smplmenu
  39.  * This a simple menu procedure
  40.    key_press = 0
  41.    paint = .T.
  42.    DO WHILE .T.
  43.       IF paint
  44.          CLEAR
  45.          @  1,26 SAY  "Zero-Balanced Distribution"
  46.          @  2,32 SAY  "Sample System"
  47.          @  1,26 SAY  "Zero-Balanced Distribution"
  48.          @  2,32 SAY  "Sample System"
  49.          @  4,34 SAY  "Main Menu"
  50.          @  5,20 TO 11,58 DOUBLE      
  51.          @  6,28 SAY  "1. Add Transaction"
  52.          @  8,28 SAY  "2. Modify Transaction"
  53.          @ 10,28 SAY  "X. Exit to Dot Prompt"
  54.          paint = .F.
  55.       ENDIF
  56.       usr_inp = "  "
  57.       @ 22,27 SAY "Enter selection " GET usr_inp PICTURE "!!"
  58.       READ
  59.       key_press = keypress()
  60.         usr_inp = IIF(key_press=12,"X",usr_inp)          
  61.       usr_inp = LTRIM(TRIM(usr_inp))
  62.       IF LEN(usr_inp) = 0
  63.          LOOP
  64.       ENDIF
  65.       DO CASE
  66.       CASE usr_inp = "1"
  67.          paint = .T.
  68.          @  4,0  CLEAR
  69.          @  4,31 SAY  "Add Transaction"
  70.          DO WHILE key_press <> 12    && Esc
  71.             c_new_rec = .T.
  72.             DO gethdr
  73.          ENDDO
  74.       CASE usr_inp = "2"
  75.          paint = .T.
  76.          @  4,0  CLEAR
  77.          @  4,29 SAY  "Modify Transaction"
  78.            SELECT tranhdr
  79.          tran_no = 0
  80.          @ 22,0 SAY "Enter transaction number " GET m->tran_no PICTURE "999"
  81.          READ
  82.          key_press = keypress()
  83.          IF key_press = 12    && Esc
  84.             LOOP
  85.          ENDIF
  86.          LOCATE FOR Tran_No = m->tran_no
  87.          IF .NOT. EOF()
  88.             c_new_rec = .F.
  89.             DO gethdr
  90.          ENDIF
  91.       CASE usr_inp = "/" .OR. usr_inp = "X"
  92.          EXIT
  93.       ENDCASE
  94.    ENDDO
  95. RETURN
  96.  
  97. PROCEDURE gethdr
  98.  * Procedure to get or modify the transaction header
  99.  * The transaction number is assign for new transactions only
  100.  * by incrementing the last transaction.  This technique would
  101.  * not be suitable to a multi-user application.
  102.  * This procedure will also set up and call the engine if the
  103.  * transaction is accepted.
  104.    IF c_new_rec
  105.       GO BOTTOM
  106.       tran_no = tranhdr->Tran_No + 1
  107.       tran_desc = SPACE(LEN(tranhdr->Tran_Desc))
  108.       tran_amt = 0 
  109.    ELSE
  110.       tran_no = tranhdr->Tran_No
  111.       tran_desc = tranhdr->Tran_Desc
  112.       tran_amt = tranhdr->Tran_Amt
  113.    ENDIF
  114.    SET COLOR TO &vid_nrml
  115.    @  5,0 CLEAR
  116.    @  5,5 TO 11,74 DOUBLE      
  117.    @  6,10 SAY  "Transaction Number"
  118.    @  8,17 SAY  "Description"
  119.    @ 10,22 SAY  "Amount"
  120.    SET COLOR TO &vid_bright
  121.    @ 6,30  SAY  m->tran_no PICTURE "###"  
  122.    SET COLOR TO &vid_rvrs
  123.    @ 23,0 SAY "Press Esc to return to menu"
  124.    SET COLOR TO &vid_nrml
  125.    c_amc = 2
  126.    DO WHILE c_amc = 2
  127.       @ 8,30 GET m->tran_desc
  128.       @ 10,30 GET m->tran_amt PICTURE "999999.99 "
  129.       READ
  130.       @ 23,0                  && Clear Esc message
  131.       key_press = keypress()
  132.       IF key_press = 12    && Esc
  133.          RETURN
  134.       ENDIF
  135.       DO qamc WITH IIF(c_new_rec,2,1) && Add record as displayed or 
  136.                                       && Save record with changes
  137.    ENDDO
  138.    IF c_amc = 1
  139.       SELECT tranhdr
  140.       IF c_new_rec
  141.          APPEND BLANK
  142.          REPLACE Tran_No WITH m->tran_no
  143.       ENDIF
  144.       REPLACE Tran_Desc WITH m->tran_desc, ;
  145.               Tran_Amt WITH m->tran_amt
  146.       SET SAFETY OFF
  147.       SELECT Dstrwork
  148.       IF c_new_rec
  149.          ZAP
  150.          rmng_2_bal = tranhdr->Tran_Amt
  151.       ELSE
  152.          USE
  153.          SELECT trandstr
  154.          SET DELETED ON
  155.          COPY TO Dstrwork FOR Tran_No = tranhdr->Tran_No
  156.          SELECT 3
  157.          USE Dstrwork
  158.          rmng_2_bal = tranhdr->Tran_Amt - tranhdr->Dstr_Total
  159.       ENDIF
  160.       SET SAFETY ON
  161.     * Scope memory variables for distribution
  162.       STORE SPACE(LEN(trandstr->Dstr_To)) TO dstr_to
  163.       STORE 0 TO dstr_amt
  164.     * Assign procedures for engine       
  165.       zd_screen  = "DO dstrscn"
  166.       zd_display = "DO dstrdsp"
  167.       zd_init    = "DO dstrinit"
  168.       zd_get     = "DO dstrget"
  169.       zd_append  = "DO dstrapp"
  170.       zd_modify  = "DO dstrmod"
  171.       zd_insert  = "DO dstrins"
  172.       zd_delete  = "DO dstrdel"
  173.       zd_file    = "DO dstrfile"
  174.       zd_alias   = "dstrwork"
  175.     * Call the engine
  176.       DO zerodstr WITH (rmng_2_bal)
  177.    ENDIF
  178. RETURN         
  179.  
  180. PROCEDURE dstrscn          
  181.  * Paint screen for distribution
  182.  * this procedure is assigned to variable zd_screen
  183.    SELECT Dstrwork 
  184.    @ 12,0  CLEAR 
  185.    @ 12,5 TO 20,74 DOUBLE      
  186.    @ 15,6 TO 15,73 
  187.    @ 15,5 SAY CHR(199)
  188.    @ 15,74 SAY CHR(182)
  189.    @ 13,11 SAY "Distribution Item"
  190.    @ 13,37 SAY "of"
  191.    @ 14,8  SAY "Remaining to Balance"
  192.    @ 16,15 SAY "Distribute to"
  193.    @ 18,22 SAY "Amount"
  194.    SET COLOR TO &vid_bright
  195.    @ 13,31 SAY cur_item PICTURE "9999"
  196.    @ 13,40 SAY last_item PICTURE "9999"
  197.    @ 14,31 SAY rmng_2_bal PICTURE "999,999.99"
  198.    SET COLOR TO &vid_nrml
  199. RETURN
  200.  
  201. PROCEDURE dstrdsp          
  202.  * Display current distibution item
  203.  * this procedure is assigned to variable zd_dsp
  204.    SET COLOR TO &vid_bright
  205.    @ 13,31 SAY cur_item PICTURE "9999"
  206.    @ 13,40 SAY last_item PICTURE "9999"
  207.    @ 14,31 SAY rmng_2_bal PICTURE "999,999.99"
  208.    @ 16,31 SAY Dstrwork->Dstr_To
  209.    @ 18,31 SAY Dstrwork->Dstr_Amt PICTURE "999,999.99"
  210.    SET COLOR TO &vid_nrml
  211. RETURN
  212.  
  213. PROCEDURE dstrinit         
  214.  * Initialize memory variables to get an item
  215.  * this procedure is assigned to variable zd_init
  216.    dstr_to = Dstrwork->Dstr_To
  217.    dstr_amt = IIF(c_new_rec,rmng_2_bal,Dstrwork->Dstr_Amt)
  218. RETURN
  219.  
  220. PROCEDURE dstrget
  221.  * Get and read
  222.  * this procedure is assigned to variable zd_get
  223.    @ 16,31 GET m->dstr_to PICTURE REPLICATE("!",LEN(m->dstr_to))
  224.    @ 18,31 GET m->dstr_amt PICTURE "999999.99 "
  225.    READ
  226. RETURN
  227.  
  228. PROCEDURE dstrapp
  229.  * Append item to Dstrwork
  230.  * this procedure is assigned to variable zd_append
  231.    SELECT Dstrwork
  232.    APPEND BLANK
  233.    rmng_2_bal = m->rmng_2_bal - m->dstr_amt
  234.    finished = (rmng_2_bal = 0.)
  235.    DO dstrrepl
  236. RETURN
  237.  
  238. PROCEDURE dstrmod
  239.  * Modify item in Dstrwork
  240.  * this procedure is assigned to variable zd_modify
  241.  * Update rmng_2_bal with difference between old and new values, 
  242.  * and do it before the replace !!
  243.    rmng_2_bal = m->rmng_2_bal - m->dstr_amt + Dstrwork->dstr_amt
  244.    DO dstrrepl
  245. RETURN
  246.  
  247. PROCEDURE dstrins         
  248.  * Insert item in front of current item
  249.  * this procedure is assigned to variable zd_insert
  250.    SELECT Dstrwork
  251.    INSERT BLANK BEFORE
  252.    rmng_2_bal = m->rmng_2_bal - m->dstr_amt
  253.    DO dstrrepl
  254. RETURN
  255.  
  256. PROCEDURE dstrrepl
  257.  * Replace database fields with value of corresponding memory variables
  258.  * This procedure IS NOT assigned to a zd_ variable, but it is 
  259.  * called by procedures dstrapp, dstrmod, and dstrins, and keeps the
  260.  * write to database fields in a single procedure
  261.    REPLACE Dstr_To WITH m->dstr_to, Dstr_Amt WITH m->dstr_amt
  262. RETURN
  263.    
  264. PROCEDURE dstrdel
  265.  * Delete item from Dstrwork
  266.  * this procedure is assigned to variable zd_delete
  267.  * DELETE and PACK statements are in calling procedure
  268.  * only need to adjust rmng_2_bal
  269.    SELECT Dstrwork 
  270.    rmng_2_bal = rmng_2_bal + Dstrwork->dstr_amt
  271. RETURN
  272.  
  273. PROCEDURE dstrfile
  274.  * Distribution has been accepted - write it to permanent files.
  275.  * this procedure is assigned to variable zd_file
  276.  * If we are modifying a previous transaction, we need to delete the
  277.  * the old distribution if the field tranhdr->Dstr_Count is non-zero.
  278.  * After the new distribution is saved, ZAP the workfile.
  279.    SELECT Dstrwork
  280.    PACK
  281.    REPLACE tran_no WITH tranhdr->Tran_No FOR .T.
  282.    USE
  283.    SET DELETED ON
  284.    SELECT trandstr
  285.    IF tranhdr->dstr_count <> 0
  286.       LOCATE FOR Tran_No = tranhdr->Tran_No      && not using an index in this sample
  287.       DELETE WHILE trandstr->Tran_No = tranhdr->Tran_No
  288.    ENDIF
  289.    APPEND FROM Dstrwork
  290.    SELECT tranhdr
  291.    REPLACE dstr_count WITH last_item, dstr_total WITH tran_amt - rmng_2_bal
  292.    SELECT 3
  293.    SET SAFETY OFF
  294.    USE Dstrwork
  295.    ZAP
  296.    SET SAFETY ON
  297. RETURN
  298.  
  299. PROCEDURE zerodstr        
  300. * This is the top level procedure of the Zero-Balanced Distribution Engine
  301. * Parameter passed - rmng_2_balance
  302. * The calling procedure is expected to assign values in the illustrated
  303. *  manner to to the following  variables :
  304. *                                && supply mnemonic or acronym for *
  305. *     zd_screen  = "DO *scn"     && Procedure to paint screen
  306. *     zd_display = "DO *dsp"     && Display current distibution item
  307. *     zd_init    = "DO *init"    && Intialize memory varibles 
  308. *     zd_get     = "DO *get"     && GET and READ
  309. *     zd_append  = "DO *app"     && Append to end of workfile
  310. *     zd_modify  = "DO *mod"     && Modify item
  311. *     zd_insert  = "DO *ins"     && Insert in front current item
  312. *     zd_delete  = "DO *del"     && Delete current item
  313. *     zd_file    = "DO *file"    && File distribution
  314. *     zd_alias   = "alias"       && Alias of workfile
  315. *
  316. *  Macro substitution command is executed as needed to call the above 
  317. *  defined procedures and to reference the workfile. The procedures 
  318. *  in the engine, from the top:
  319. *     zerodstr    - initilizes and controls the prompt 
  320. *                   "File, Review, Append, Cancel".
  321. *     zdreview    - controls the "Enter item number (9999); Prev ..." prompt
  322. *     zdloop      - controls the "Skip, Modify, Insert, Delele" prompt 
  323. *     zdappend    - set up for appending items
  324. *     zdinput     - macro  &zd_get and control "Accept, Modify, Cancel"
  325. *     qfrac       - query  "File, Review, Append, Cancel"
  326. *     qsmid       - query  "Skip, Modify, Insert, Delele"
  327. *  The following procedure are general purpose and used, as well, outside
  328. *  the engine:
  329. *     qamc        - query  "Accept, Modify, Cancel"
  330. *     qyesno      - query  "Yes No" to parameter question
  331. *     pause       - suspend for up to 60 seconds
  332. *     hlpcr       - press Enter to continue
  333. *     keypress    - returns low value of READKEY()
  334. *
  335. PARAMETER rmng_2_bal
  336. PRIVATE dstr_mode,NO_INPUT,APPEND_ITM,MODIFY_ITM,INSERT_ITM
  337. PRIVATE c_amc,c_smid,c_frac,c_new_rec
  338. PRIVATE c_item,last_item
  339. STORE 0 TO c_amc,c_smid,c_frac
  340. STORE .F. TO c_new_rec
  341. NO_INPUT = 0
  342. APPEND_ITM = 1
  343. MODIFY_ITM = 2
  344. INSERT_ITM = 3
  345. IF TYPE("zd_rvwonly") <> "L"
  346.    PRIVATE zd_rvwonly
  347.    zd_rvwonly = .F.
  348. ENDIF
  349. IF TYPE("rvwmsg_row") <> "N"
  350.    PRIVATE rvwmsg_row
  351.    rvwmsg_row = 23
  352. ELSE
  353.    IF rvwmsg_row < 0 .OR. rvwmsg_row > 24
  354.       PRIVATE rvwmsg_row
  355.       rvwmsg_row = 23
  356.    ENDIF
  357. ENDIF
  358. IF TYPE("rvwmsg_col") <> "N"
  359.    PRIVATE rvwmsg_col
  360.    rvwmsg_col = 0
  361. ELSE
  362.    IF rvwmsg_col < 0 .OR. rvwmsg_col > 64
  363.       PRIVATE rvwmsg_col
  364.       rvwmsg_col = 0
  365.    ENDIF
  366. ENDIF
  367. SELECT &zd_alias
  368. last_item = RECCOUNT()
  369. cur_item = IIF(last_item=0,0,1)
  370. GO TOP
  371. IF zd_rvwonly
  372.    &zd_screen
  373.    IF cur_item <> 0
  374.       &zd_display
  375.    ENDIF
  376.    DO zdreview
  377.    SELECT &zd_alias
  378.    SET SAFETY OFF
  379.    ZAP
  380.    SET SAFETY ON   
  381.    RETURN
  382. ENDIF
  383. dstr_mode = IIF(last_item=0, APPEND_ITM,NO_INPUT)
  384. c_frac = 0
  385. DO WHILE c_frac = 0
  386.    IF dstr_mode = APPEND_ITM
  387.       DO zdappend
  388.    ELSE
  389.       &zd_screen
  390.       IF cur_item <> 0
  391.          &zd_display
  392.       ENDIF
  393.    ENDIF
  394.    DO qfrac
  395.    DO CASE
  396.    CASE  c_frac = 1                                    && File distribution
  397.       IF last_item = 0
  398.          IF qyesno("File with zero items ? ","N") <> 1
  399.             c_frac = 0
  400.             LOOP
  401.          ENDIF  
  402.       ENDIF  
  403.       &zd_file
  404.    CASE  c_frac = 2                                    && Review items
  405.       DO zdreview
  406.       dstr_mode = NO_INPUT
  407.       c_frac = 0
  408.    CASE  c_frac = 3                                    && Append items
  409.       c_new_rec = .T.
  410.       cur_item = last_item
  411.       dstr_mode = APPEND_ITM
  412.       c_frac = 0
  413.    CASE  c_frac = 4  .OR. c_frac = -1                  && Cancel distribution
  414.       SELECT &zd_alias
  415.       SET SAFETY OFF
  416.       ZAP
  417.       SET SAFETY ON   
  418.       @ 23,0
  419.       ?? "No Action!"
  420.       DO pause WITH 2
  421.       @ 23,0
  422.       ** will exit
  423.    ENDCASE
  424. ENDDO
  425. *
  426. RETURN                    
  427.  
  428. PROCEDURE zdreview        
  429. *
  430. PRIVATE ok, all_left
  431. IF last_item = 0
  432.    @ 22,0 CLEAR
  433.    ?? "There are no items to review."
  434.    DO hlpcr WITH "Press ─┘ to continue "
  435. ENDIF
  436. all_left = .F.
  437. key_press = 0
  438. DO WHILE .T.
  439.    IF last_item = 0       && All items can be deleted
  440.       RETURN
  441.    ENDIF
  442.    key_press = IIF(key_press=15 .OR. key_press=271,0,key_press)
  443.    IF .NOT. all_left  .AND. key_press = 0
  444.       usr_inp = "    "
  445.       @ 22,0 CLEAR
  446. ?? "Enter item number (9999); Previous, Next, or All remaining; End review"
  447. ?  "[Press ─┘ for item (last) displayed. Also:   PgUp PgDn]"                  
  448.       SET COLOR TO &vid_bright 
  449.       @ 22,26 SAY "P"
  450.       @ 22,36 SAY "N"
  451.       @ 22,45 SAY "A"
  452.       @ 22,60 SAY "E"
  453.       SET COLOR TO &vid_nrml
  454.       @ 22,72 GET usr_inp  PICTURE "!!!!" 
  455.       READ 
  456.       key_press = keypress()
  457.    ENDIF
  458.    key_press = IIF(key_press=15,0,key_press)
  459.    usr_inp = TRIM(usr_inp)
  460.    DO CASE
  461.    CASE usr_inp $ "E/" .OR. key_press = 12 .OR. usr_inp = "0000"
  462.       @ 22,0 CLEAR
  463.       RETURN 
  464.    CASE  .NOT. all_left .AND. LEN(usr_inp) = 0 .AND. key_press = 0
  465.       DO zdloop 
  466.    CASE usr_inp = "A" .OR. all_left
  467.       try_item = IIF(all_left,cur_item+1,cur_item) 
  468.       all_left = .T. 
  469.       IF try_item > last_item 
  470.          all_left = .F. 
  471.          cur_item = IIF(last_item > 0, 1, 0)
  472.          GO TOP
  473.          &zd_screen
  474.          IF cur_item <> 0
  475.             &zd_display
  476.          ENDIF
  477.       ELSE 
  478.          SELECT &zd_alias 
  479.          GOTO try_item 
  480.          cur_item = try_item 
  481.          DO zdloop 
  482.       ENDIF 
  483.    CASE usr_inp = "N" .OR. key_press = 5   && DownArrow - next item
  484.       try_item = cur_item + 1 
  485.       IF try_item <= last_item 
  486.          SELECT &zd_alias 
  487.          GOTO try_item 
  488.          cur_item = try_item 
  489.          DO zdloop 
  490.       ENDIF 
  491.    CASE usr_inp = "P" .OR. key_press = 4   && UpArrow - previous item
  492.       try_item = cur_item - 1 
  493.       IF try_item > 0 
  494.          SELECT &zd_alias 
  495.          GOTO try_item 
  496.          cur_item = try_item 
  497.          DO zdloop 
  498.       ENDIF 
  499.    CASE key_press = 6                      && PgUp - first item
  500.       SELECT &zd_alias
  501.       GO TOP
  502.       cur_item = 1
  503.       DO zdloop 
  504.    CASE key_press = 7                      && PgDn - last item
  505.       SELECT &zd_alias
  506.       GO BOTTOM
  507.       cur_item = last_item
  508.       DO zdloop 
  509.    OTHERWISE
  510.       try_item = VAL(usr_inp) 
  511.       IF try_item > 0 .AND. try_item <= last_item 
  512.          SELECT &zd_alias 
  513.          GOTO try_item 
  514.          cur_item = try_item 
  515.          DO zdloop 
  516.       ENDIF
  517.       key_press = 0
  518.    ENDCASE          
  519. ENDDO         
  520. *
  521. RETURN                    
  522.  
  523. PROCEDURE zdloop          
  524. *
  525. key_press = 0
  526. SELECT &zd_alias
  527. c_bright = .F.
  528. &zd_screen
  529. &zd_display
  530. IF zd_rvwonly
  531.    @ 22,0 CLEAR
  532.    SET COLOR TO &vid_bright
  533.    @ rvwmsg_row,rvwmsg_col SAY 'Review Only'
  534.    SET COLOR TO &vid_nrml
  535.    DO hlpcr WITH "Press ─┘ to continue "
  536.    RETURN
  537. ENDIF
  538. c_smid = 0 
  539. DO WHILE c_smid = 0
  540.    DO qsmid             && Skip, Modify, Insert, or Delete ? 
  541.    DO CASE
  542.    CASE  c_smid = 1 .OR. c_smid = -1                        &&    S k i p
  543.       RETURN
  544.    CASE  c_smid = 2                                         &&    M o d i f y
  545.       SET COLOR TO &vid_bright
  546.       @ rvwmsg_row,rvwmsg_col SAY "Modifying Item"
  547.       SET COLOR TO &vid_nrml
  548.       dstr_mode = MODIFY_ITM
  549.       c_new_rec = .F.
  550.       &zd_init
  551.       DO zdinput
  552.       IF c_amc = 1
  553.          &zd_modify
  554.       ELSE 
  555.          &zd_display
  556.          STORE 0 TO c_amc,c_smid
  557.          ** reexecute WHILE c_smid = 0 loop
  558.       ENDIF
  559.    CASE  c_smid = 3                                         &&    I n s e r t
  560.       SET COLOR TO &vid_bright
  561.       @ rvwmsg_row,rvwmsg_col SAY "Inserting Item"
  562.       SET COLOR TO &vid_nrml
  563.       dstr_mode = INSERT_ITM
  564.       c_new_rec = .T.
  565.       &zd_init
  566.       DO zdinput
  567.       IF c_amc = 1
  568.          &zd_insert
  569.          last_item = last_item + 1
  570.       ELSE 
  571.          &zd_display
  572.          STORE 0 TO c_amc,c_smid
  573.          ** reexecute WHILE c_smid = 0 loop
  574.       ENDIF
  575.    CASE  c_smid = 4                                         &&    D e l e t e
  576.       IF qyesno("Really delete this item ?","N") = 1
  577.          &zd_delete
  578.          DELETE
  579.          PACK
  580.          last_item = last_item - 1
  581.          cur_item = IIF(cur_item > last_item, last_item, cur_item)
  582.          cur_item = IIF(all_left .AND. (cur_item > 0) , cur_item - 1, cur_item)
  583.          IF cur_item <> 0 
  584.             GOTO cur_item
  585.          ENDIF
  586.       ENDIF
  587.    ENDCASE
  588. ENDDO
  589. IF .NOT. all_left
  590.    &zd_screen
  591.    IF cur_item <> 0
  592.       &zd_display
  593.    ENDIF
  594. ENDIF  
  595. *
  596. RETURN                    
  597.  
  598. PROCEDURE zdappend        
  599. *
  600. PRIVATE finished
  601. c_new_rec = .T.
  602. finished = .F.
  603. DO WHILE .NOT. finished
  604.    cur_item = cur_item + 1
  605.    &zd_screen
  606.    &zd_init
  607.    DO zdinput
  608.    IF c_amc = 1
  609.       &zd_append
  610.       last_item = last_item + 1
  611.    ELSE 
  612.       cur_item = cur_item - 1
  613.    ENDIF
  614.    finished = finished .OR. (keypress() = 12)    && Esc
  615.    IF finished 
  616.       GO cur_item
  617.       &zd_display
  618.    ENDIF
  619. ENDDO
  620. *
  621. RETURN                    
  622.  
  623. PROCEDURE zdinput
  624.    c_amc = 2
  625.    DO WHILE c_amc = 2
  626.       &zd_get
  627.       @ rvwmsg_row,rvwmsg_col SAY "              "
  628.       key_press = keypress()
  629.       IF key_press = 12    && Esc
  630.          RETURN
  631.       ENDIF
  632.       DO qamc WITH IIF(dstr_mode = MODIFY_ITM,1,2)
  633.    ENDDO
  634. RETURN                    
  635.  
  636. PROCEDURE qfrac           
  637. *
  638. PRIVATE usr_inp
  639. @ 23,0
  640. IF TYPE("no_bal_msg")<> "L"
  641.    PRIVATE no_bal_msg
  642.    STORE .F. TO no_bal_msg
  643. ENDIF
  644. IF no_bal_msg
  645.    usr_inp = "F "
  646. ELSE
  647.    SET COLOR TO &vid_rvrs
  648.    IF rmng_2_bal = 0
  649.       ?? "Distribution is in balance"
  650.       usr_inp = "F "
  651.    ELSE
  652.       ?? "Distribution is not in balance",CHR(7)
  653.       usr_inp = IIF(last_item = 0,"A ","R ")
  654.    ENDIF
  655.    SET COLOR TO &vid_nrml
  656. ENDIF
  657. c_frac = 0
  658. DO WHILE c_frac = 0
  659.    @ 22,0
  660.    @ 22,0 SAY "File, Review, Append, Cancel (F/R/A/C) " ;
  661.       GET usr_inp PICTURE "!!"
  662.    READ
  663.    key_press = keypress()
  664.    DO CASE
  665.    CASE  usr_inp = "/" .OR. key_press = 12    && Esc
  666.       c_frac = -1
  667.    CASE  usr_inp = "F" .OR. usr_inp = "1"
  668.       c_frac = 1
  669.    CASE  usr_inp = "R" .OR. usr_inp = "2"
  670.       c_frac = 2
  671.    CASE  usr_inp = "A" .OR. usr_inp = "3"
  672.       c_frac = 3
  673.    CASE  usr_inp = "C" .OR. usr_inp = "4"
  674.       c_frac = 4
  675.    ENDCASE
  676.    usr_inp = "  "
  677. ENDDO
  678. @ 22,0 CLEAR
  679. *
  680. RETURN                    
  681.  
  682. PROCEDURE qsmid           
  683. *
  684.    PRIVATE usr_inp, col
  685.    usr_inp = 1
  686.    @ 22,0 CLEAR
  687.    IF TYPE("all_left") <> "L"
  688.       PRIVATE all_left
  689.       all_left = .F.
  690.    ENDIF
  691.    col = IIF(all_left,10,25)
  692.    @ 23,col      PROMPT "Skip"   MESSAGE "No change to item displayed."
  693.    @ 23,col+6    PROMPT "Modify" MESSAGE "Change item displayed." 
  694.    @ 23,col+14   PROMPT "Insert" MESSAGE "Insert new item before item displayed."
  695.    @ 23,col+22   PROMPT "Delete" MESSAGE "Delete item displayed."
  696.    IF all_left
  697.      @ 23,col+30 PROMPT 'Cancel "All Remaining" Option' MESSAGE "Also skip item displayed."
  698.    ENDIF
  699.    SET MESSAGE TO 24
  700.    MENU TO usr_inp
  701.    key_press = keypress()
  702.    @ 23,0 CLEAR
  703.    DO CASE
  704.    CASE  usr_inp = 1
  705.       c_smid = 1
  706.    CASE  usr_inp = 2
  707.       c_smid = 2
  708.    CASE  usr_inp = 3
  709.       c_smid = 3
  710.    CASE  usr_inp = 4
  711.       c_smid = 4
  712.    CASE  usr_inp = 0 .OR. usr_inp = 5
  713.       press = "/"
  714.       c_smid = -1
  715.       all_left = .F.
  716.    ENDCASE
  717. *
  718. RETURN                    
  719.  
  720. PROCEDURE qamc            
  721. *
  722. PARAMETER qamc_type
  723. * 1  Modify existing record
  724. * 2  Add new record
  725. * 3  Proceed as displayed
  726. press = " "
  727. PRIVATE usr_inp
  728. usr_inp = 1
  729. @ 23,29 PROMPT "Accept" MESSAGE IIF(qamc_type = 3,"Proceed as specified.", ;
  730.    IIF(qamc_type=2,"Add record as displayed.","Save record with changes."))
  731. @ 23,37 PROMPT "Modify" MESSAGE IIF(qamc_type = 3,"Change specifications.", ;
  732.    "Make changes to record.")
  733. @ 23,45 PROMPT "Cancel" MESSAGE IIF(qamc_type = 3,"Return to menu.", ;
  734.    IIF(qamc_type=2,"Do not add record.","Disregard any changes made."))
  735. SET MESSAGE TO 24
  736. MENU TO usr_inp
  737. key_press = keypress()
  738. @ 23,0 CLEAR
  739. DO CASE
  740. CASE  usr_inp = 1
  741.    c_amc = 1
  742. CASE  usr_inp = 2
  743.    c_amc = 2
  744. CASE  usr_inp = 3
  745.    c_amc = 3
  746. CASE  usr_inp = 0
  747.    press = "/"
  748.    c_amc = -1
  749. ENDCASE
  750. *
  751. RETURN                    
  752.  
  753. PROCEDURE qyesno          
  754. *
  755. PARAMETERS prompt,initial
  756. PRIVATE col,test,usr_inp
  757. initial = UPPER(LEFT(initial+"  ",2))
  758. usr_inp = IIF(initial = "Y",2,1)
  759. @ 23,0 CLEAR
  760. test = LEN(TRIM(prompt))
  761. col = (80-LEN(prompt)-9)/2
  762. @ 23,col SAY prompt
  763. @ 23,col+test+7 PROMPT "No"
  764. @ 23,col+test+2 PROMPT "Yes"
  765. MENU TO usr_inp
  766. key_press = keypress()
  767. @ 23,0 CLEAR
  768. * Return Value is 1 if Y
  769. *                 0 if N
  770. *                -1 if Esc
  771. RETURN usr_inp - 1        
  772.  
  773. PROCEDURE pause           
  774. *
  775. * use to pause between 0 & 60 seconds
  776. * if outside range, prompt
  777. PARAMETER kount
  778. PRIVATE start,now
  779. IF kount < 0 .OR. kount > 60
  780.    DO hlpcr WITH 'Press ─┘ to continue '
  781.    RETURN
  782. ENDIF
  783. start = VAL(RIGHT(TIME(),2))
  784. now = start
  785. DO WHILE start+kount > now
  786.    now = VAL(RIGHT(TIME(),2))
  787.    IF now < start
  788.       now = now + 60
  789.    ENDIF
  790. ENDDO
  791. *
  792. RETURN                    
  793.  
  794. PROCEDURE hlpcr           
  795. *
  796. PARAMETER message
  797. IF TYPE("bell_off") <> "L"
  798.    PRIVATE bell_off
  799.    bell_off = .F.
  800. ENDIF
  801. @ 23,0 CLEAR
  802. ?? IIF(bell_off,"",CHR(7))
  803. press = " "
  804. @ 23,0 SAY message GET press
  805. READ
  806. key_press = keypress()
  807. press = IIF(key_press=12,"/",press)    && compatible with older versions
  808. @ 23,0 CLEAR
  809. *
  810. RETURN                    
  811.  
  812. PROCEDURE keypress        
  813. *
  814. key_press = READKEY()
  815. key_press = IIF(key_press>36,key_press-256,key_press)
  816. *
  817. RETURN key_press          
  818.  
  819.